home *** CD-ROM | disk | FTP | other *** search
/ BMUG PD-ROM 1995 Fall / PD-ROM F95.toast / Utilities / Text Utils / Alpha 5.81 ƒ / Tcl / SystemCode / shell.tcl < prev    next >
Encoding:
Text File  |  1994-07-07  |  8.5 KB  |  349 lines  |  [TEXT/ALFA]
  1.  
  2. ################################################################################
  3. # Shell routines.
  4. ################################################################################
  5.  
  6.  
  7. proc setShellMode {} {
  8.     setTclMode
  9.     changeMode "Csh"
  10.     insertMenu "Tcl"
  11. }
  12.  
  13. proc initShell {} {
  14.     insertText "Welcome to Alpha's Tcl shell."
  15.     insertText -w [lindex [winNames] 0] [shellPrompt]
  16. }
  17.  
  18. # Return the prompt. We want the window name because some of the commands
  19. # we evaluate (such as 'edit') open a new window, and we want the insertion
  20. # to be done in the shell window.
  21. proc shellPrompt {} {
  22.     regexp "(\[^:\]*):$" [pwd] crDum crDir
  23.     return "\r$crDir> "
  24. }
  25.  
  26.  
  27. # Called at all carriage returns.
  28. proc carriageReturn {} {
  29.     global mode
  30.     global indentOnCR
  31.     set indentString ""
  32.     deleteText [getPos] [selEnd]
  33.     if {$indentOnCR} {
  34.         set pos [getPos]
  35.         set text [getText [lineStart $pos] $pos]
  36.         for {set i 0; set len [string length $text]} {$i <= $len} {incr i} {
  37.             set c [string index $text $i]
  38.             if {($c != "\t") && ($c != "\ ")} {
  39.                 set indentString [string range $text 0 [expr $i-1]]
  40.                 break
  41.             }
  42.         }
  43.     }
  44.     insertText "\r" $indentString
  45. }
  46.  
  47.  
  48. proc tclCarriageReturn {} {
  49.     global mode
  50.     global _text
  51.     global _returnText
  52.     set pos [getPos]
  53.     set ind [string first ">" [getText [lineStart $pos] $pos]]
  54.     if {$ind < 0} {
  55.         carriageReturn
  56.         return
  57.     }
  58.     set lStart [expr [lineStart $pos]+$ind+2]
  59.     endOfLine
  60.     set _text [getText $lStart [getPos]]
  61.     set fileName [lindex [winNames] 0]
  62.     if {[getPos] != [maxPos]} {
  63.         goto [maxPos]
  64.         insertText -w $fileName $_text
  65.     }
  66.     if {[string first "Toolserver" $fileName] != -1} {
  67.         if {![catch {dosc -n ToolServer -s $_text} _returnText]} {
  68.             insertText "\r" $_returnText
  69.         } else {
  70.             insertText "\r"
  71.         }
  72.         mpwPrompt
  73.     } else {
  74.         uplevel #0 {catch $_text _returnText}
  75.         if {[string length $_returnText]} {
  76.             insertText -w $fileName "\r" $_returnText [shellPrompt]
  77.         } else {
  78.             insertText -w $fileName [shellPrompt]
  79.         }
  80.     }
  81.     unset _text
  82.     unset _returnText
  83. }
  84. bind '\r' carriageReturn
  85. bind '\r' tclCarriageReturn "Csh"
  86. bind '\r' tclCarriageReturn "MPW"
  87.  
  88. proc startMPW {} {
  89.     global toolserverPath
  90.  
  91.     if {![string length [checkRunning ToolServer MPSX toolserverPath]]} return
  92.  
  93.     insertText "Welcome to Alpha's MPW shell (using ToolServer via AppleEvents)."
  94.     bind '\r' tclCarriageReturn "MPW"
  95.     carriageReturn
  96.     mpwPrompt
  97. }
  98. proc mpwPrompt {} {
  99.     insertText "mpw> "
  100. }
  101.  
  102. proc setMPWMode {} {
  103.     changeMode "MPW"
  104. }
  105.  
  106. #    tclCarriageReturn
  107.  
  108.  
  109.  
  110. #=============================================================================
  111. #    Shell Aliases
  112. #=============================================================================
  113.  
  114.  
  115. proc l {args} {
  116.     eval [concat "ls -CF" $args]}
  117.  
  118. proc ll {args} {
  119.     eval [concat "ls -l" $args]}
  120.  
  121.  
  122. proc wc {args} {
  123.     set totChars 0
  124.     set totLines 0
  125.     set totWords 0
  126.     set args [glob -nocomplain $args]
  127.     foreach file $args {
  128.         set id [open $file]
  129.         set chars [string length [set text [read $id]]]
  130.         set lines [llength [split $text "\n"]]
  131.         set words [llength [split $text]]
  132.         insertText [format "\r%8d%8d%8d    $file" $lines $words $chars]
  133.         set totChars [expr $totChars+$chars]
  134.         set totWords [expr $totWords+$words]
  135.         set totLines [expr $totLines+$lines]
  136.         close $id
  137.     }
  138.     if {[llength $args] > 1} {
  139.         insertText [format "\r%8d%8d%8d    total" $totLines $totWords $totChars]
  140.     }
  141. }
  142.  
  143. ###########################################################################
  144. #  better-cp-mv.tcl  -- modification of your routines, by Mark Nagata
  145. #  for Alpha 5.72,  1/04/94
  146. ###########################################################################
  147. proc cp args {
  148.     if {[set len [llength $args]] < 2} {
  149.         error "usage: cp <file1> <file2>\r       cp <file1> .... <dir>"
  150.     }
  151.     set len [expr $len-1]
  152.     if {![regexp {.*[^:]} [lindex $args $len] dir]} {
  153.         set dir [string range [lindex $args $len] 1 end]
  154.     }
  155.     if {![regexp {:} $dir] && $dir != ""} {
  156.         set dir [concat :$dir]}
  157.     set args [lreplace $args $len $len]
  158.     set files {}
  159.     foreach arg $args {
  160.         append files " " [glob $arg]
  161.     }
  162.     set report ""
  163.     if {[llength $files] == 1} {
  164.         set f [lindex $files 0]
  165.         if {[file exists $dir]} {
  166.             set targ $dir:[file tail $f]
  167.             append report $f\ ->\ $targ \r 
  168.             copyFile $f $targ
  169.         } else {
  170.             append report $f\ ->\ $dir \r
  171.             copyFile $f $dir
  172.         }
  173.     } else {
  174.         foreach f $files {
  175.             set targ $dir:[file tail $f]
  176.             append report $f\ ->\ $targ \r
  177.             if {[catch {copyFile $f $targ} that]} {
  178.                 alertnote "Error copying '$f' -> '$targ': $that"
  179.             }
  180.         }
  181.     }
  182.     echo $report
  183. }
  184.  
  185. proc mv args {
  186.     if {[set len [llength $args]] < 2} {
  187.         error "usage: mv <file1> <file2>\r       mv <file1> .... <dir>"
  188.     }
  189.     set len [expr $len-1]
  190.     if {![regexp {.*[^:]} [lindex $args $len] dir]} {
  191.         set dir [string range [lindex $args $len] 1 end]
  192.     }
  193.     if {![regexp {:} $dir] && $dir != ""} {
  194.         set dir [concat :$dir]}
  195.     set args [lreplace $args $len $len]
  196.     set files {}
  197.     foreach arg $args {
  198.         append files " " [glob $arg]
  199.     }
  200.     set report ""
  201.     if {[llength $files] == 1} {
  202.         set f [lindex $files 0]
  203.         if {[file exists $dir]} {
  204.             set targ $dir:[file tail $f]
  205.             append report $f\ >->\ $targ \r
  206.             moveFile $f $targ
  207.         } else {
  208.             append report $f\ >->\ $dir \r
  209.             moveFile $f $dir
  210.         }
  211.     } else {
  212.         foreach f $files {
  213.             set targ $dir:[file tail $f]
  214.             append report $f\ >->\ $targ \r
  215.             if {[catch {moveFile $f $targ} that]} {
  216.                 alertnote "Error moving '$f' -> '$targ': $that"
  217.             }
  218.         }
  219.     }
  220.     echo $report
  221. }
  222.  
  223.  
  224. proc rm args {
  225.     set files {}
  226.     foreach arg $args {
  227.         append files " " [glob $arg]
  228.     }
  229.     foreach f $files {
  230.         removeFile $f
  231.     }
  232. }
  233.  
  234.  
  235. proc getTypeCreator {f} {
  236.     set l [ls -l $f]
  237.     set len [llength $l]
  238.     list [lindex $l [expr $len-4]] [lindex $l [expr $len-3]]
  239. }
  240.  
  241.  
  242. #================================================================================
  243.  
  244.  
  245. proc tclFileCompletion {} {
  246.     set silly "*"
  247.     set pos [getPos]
  248.     set res [search -f 0 -i 0 -m 0 -r 1 -n {["\{ \t\r]} [expr $pos - 1]]
  249.     if {[string length $res]} {
  250.         set from [lindex $res 1]
  251.         if {$from < $pos} {
  252.             set pd [pwd]
  253.             set text [getText $from $pos]
  254.             if {[string index $text 0] == ":"} {
  255.                 set pd [string trimright $pd ":"]
  256.             }
  257.             if {[catch {glob $pd$text$silly} globbed]} {
  258.                 set globbed [glob $text$silly]
  259.                 set pd ""
  260.             }
  261.             if {[llength $globbed] == 1} {
  262.                 set len [string length $pd$text]
  263.                 insertText [string range [lindex $globbed 0] $len end]
  264.             } elseif {[llength $globbed] != 0} {
  265.                 set globbed [lsort $globbed]
  266.                 set one [lindex $globbed 0]
  267.                 set two [lindex $globbed end]
  268.                 
  269.                 set len [string length $pd$text]
  270.                 set one [string range $one $len end]
  271.                 set two [string range $two $len end]
  272.                 
  273.                 set elen [string length $one]
  274.                 if {[string length $two] < $elen} {
  275.                     set elen [string length $two]
  276.                 }
  277.                 set len 0
  278.                 set str ""
  279.                 while {($len < $elen) && ([string match $str[string index $one $len]$silly $two])} {
  280.                     append str [string index $one $len]
  281.                     incr len
  282.                 }
  283.  
  284.                 if {!$len} {
  285.                     set elen [string length $pd]
  286.                     foreach g $globbed {
  287.                         lappend short [string range $g $elen end]
  288.                     }
  289.                     set blah [getText [lineStart [getPos]] [getPos]]
  290.                     insertText "\r" $short "\r" $blah
  291.                 } else {
  292.                     insertText $str
  293.                 }
  294.             }
  295.         }
  296.     }
  297. }
  298.  
  299.  
  300.  
  301. #================================================================================
  302. # To prevent ambiguity, 'from' is assumed to be a complete pathname, ending
  303. # in a directory name. If it doesn't end w/ a colon, one is added. 'to' is
  304. # assumed to be the parent directory of the top directory we are creating.
  305. #================================================================================
  306. proc cpdir {from to} {
  307.     set cwd [pwd]
  308.     if {[string match ":*" $from] || [string match ":*" $to] ||
  309.         ![file exists $from] || ![file exists $to]} {
  310.         error "'cpdir' args must be complete pathnames of existing folders."
  311.     }
  312.     if {![string match "*:" $from]} {append from ":"}
  313.     if {![string match "*:" $to]} {append to ":"}
  314.     
  315.     if {![file isdir $from] || ![file isdir $to]} {
  316.         exit 1
  317.     }
  318.         
  319.     cphier $from $to
  320.     cd $cwd
  321. }
  322.  
  323. proc cphier {from to} {
  324.     set dir [file tail [string trimright $from ":"]]
  325.     cd $to
  326.     mkdir "$dir"
  327.     foreach f [glob "$from*"] {
  328.         if {[file isdir $f]} {
  329.             cphier "$f:" "$to$dir:"
  330.         } else {
  331.             cp $f $to$dir:
  332.         }
  333.     }
  334. }
  335.  
  336.  
  337. if {![string length [info commands oldMkdir]]} {
  338.     rename mkdir oldMkdir
  339.     rename rmdir oldRmdir
  340. }
  341.  
  342. proc mkdir {dir} {
  343.     oldMkdir [list $dir]
  344. }
  345.  
  346. proc rmdir {dir} {
  347.     oldRmdir [list $dir]
  348. }
  349.